C---------------------------------------------------------
C
C      FORTRAN 77 SCANNER MAIN CONTROL SUBROUTINE
C      ------------------------------------------
C
C---------------------------------------------------------
C
C  LSTTKN      IS THE LAST TOKEN TYPE RETURNED
C  CMTSTR      IS USED TO HOLD COMMENT BLOCKS
C  NXTCMT      IS THE NEXT COMMENT LINE TO BE RETURNED
C  LSTCMT      IS THE LAST COMMENT LINE IN CMTSTR
C
      SUBROUTINE XSCN77 (SRC, LST, TKNVAL, TKNLEN, TKNSTR, STATUS)
C
C  THIS PARAMETER SETS THE MAXIMUM LENGTH OF A COMMENT BLOCK IN
C  LINES. NOTE THAT IT MUST BE SET TO THE SAME VALUE IN GETBUF
C  AS IT DIMENSIONS AN ARRAY IN COMMON.
C
      INTEGER MAXCMT
      PARAMETER (MAXCMT = 1000)
 
      COMMON /IOCNLS/ SOURCE,LISTNG
      INTEGER         SOURCE,LISTNG
      COMMON /TOKENC/ TKNTYP,KTFLAG,ITKNCH,TKNCHR(1327)
      INTEGER         TKNTYP,       ITKNCH,TKNCHR
      LOGICAL                KTFLAG
      COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
      INTEGER         TOKNUM, STMNUM, PUNUM, PUNAME(134)
      COMMON /CMTSAV/ CMTSTR, LSTCMT, NXTCMT, LSTTKN
      INTEGER         LSTCMT, NXTCMT, CMTSTR(81, MAXCMT), LSTTKN
      COMMON /ERROCC/ NRCVER
      INTEGER         NRCVER
      INTEGER         SRC,LST, STATUS, TKNVAL, TKNLEN, CMT, NXTNAM
      INTEGER         TKNSTR(*), FIRST
      INTEGER         LENGTH
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
C
      SAVE
      DATA FIRST/0/
C
C  INITIALISATION........
C
      IF(STATUS .EQ. -101) THEN
        FIRST = 0
        RETURN
      ENDIF
 
      IF (FIRST .EQ. 0) THEN
        TOKNUM = 0
        STMNUM = 1
        PUNUM  = 1
        PUNAME(1) = 36
        PUNAME(2) = 77
        PUNAME(3) = 65
        PUNAME(4) = 73
        PUNAME(5) = 78
        PUNAME(6) = 129
        LISTNG = LST
        SOURCE = SRC
        NRCVER = 0
        LSTTKN = 0
        LSTCMT = 0
        NXTCMT = 0
        NXTNAM = 0
        FIRST = 1
        CALL INISCN
      ENDIF
 
      IF(LSTTKN .EQ. TCMMNT) THEN
        NXTCMT = NXTCMT + 1
        IF(NXTCMT .GT. MAXCMT) NXTCMT = 1
        IF(CMTSTR(1, NXTCMT) .NE. 36) THEN
          TKNVAL = TCMMNT
          CALL SCOPY(CMTSTR(1, NXTCMT), 1, TKNSTR, 1)
          TKNLEN = LENGTH(TKNSTR)
          STATUS = -2
          RETURN
        ENDIF
      ELSE IF(LSTTKN .EQ. TZEOF) THEN
          IF(NRCVER .LT. 0) THEN
            STATUS = -1002
          ELSE IF(NRCVER .GT. 0) THEN
            STATUS = -1
          ELSE
            STATUS = -2
          ENDIF
        RETURN
      ENDIF
 
      CALL SCANNR
      STATUS = -2
      LSTTKN = TKNTYP
 
      IF(TKNTYP .NE. TCMMNT) THEN
        TKNVAL = TKNTYP
        TKNLEN = ITKNCH
        IF (ITKNCH .GT. 0) THEN
          TKNCHR(ITKNCH+1) = 129
          CALL SCOPY(TKNCHR, 1, TKNSTR, 1)
        ENDIF
        IF(TKNTYP .EQ. TZEOF) THEN
          IF(NRCVER .LT. 0) THEN
            STATUS = -1002
          ELSE IF(NRCVER .GT. 0) THEN
            STATUS = -1
          ELSE
            STATUS = -2
          ENDIF
        ELSE IF(TKNTYP .EQ. TZEOS) THEN
          IF(NXTNAM .GT. 0) THEN
            IF(NXTNAM .EQ. 1) THEN
              CALL SCNERR(24)
            ELSE IF(NXTNAM .EQ. 2) THEN
              PUNAME(1) = 36
              PUNAME(2) = 66
              PUNAME(3) = 76
              PUNAME(4) = 79
              PUNAME(5) = 67
              PUNAME(6) = 75
              PUNAME(7) = 129
            ELSE IF(NXTNAM .EQ. 3) THEN
              PUNAME(1) = 36
              PUNAME(2) = 77
              PUNAME(3) = 65
              PUNAME(4) = 73
              PUNAME(5) = 78
              PUNAME(6) = 129
            ENDIF
            NXTNAM = 0
          ENDIF
          STMNUM = STMNUM + 1
        ELSE IF(TKNTYP .EQ. TEND) THEN
          STMNUM = 0
          PUNUM  = PUNUM + 1
          PUNAME(1) = 36
          PUNAME(2) = 77
          PUNAME(3) = 65
          PUNAME(4) = 73
          PUNAME(5) = 78
          PUNAME(6) = 129
        ELSE IF(TKNTYP .EQ. TPROGR) THEN
          NXTNAM = 3
        ELSE IF(TKNTYP .EQ. TBLOCK) THEN
          NXTNAM = 2
        ELSE IF(TKNTYP .EQ. TSUBRO .OR. TKNTYP .EQ. TFUNCT) THEN
          NXTNAM = 1
        ELSE IF(TKNTYP .EQ. TNAME) THEN
          IF(NXTNAM .GT. 0) THEN
            CALL SCOPY(TKNSTR, 1, PUNAME, 1)
            NXTNAM = 0
          ENDIF
        ENDIF
      ELSE
        TKNVAL = TCMMNT
        NXTCMT = NXTCMT + 1
        IF(NXTCMT .GT. MAXCMT) NXTCMT = 1
        CALL SCOPY(CMTSTR(1, NXTCMT), 1, TKNSTR, 1)
        TKNLEN = LENGTH(TKNSTR)
      ENDIF
 
      END
C-----------------------------------------------------------------------
C
C GET BUFFER
C            GET A BUFFER OF TEXT. THE BUFFER IS 80 CHARACTERS LONG
C            MAXIMUM (MBUFFR) AND IS RETURNED CONTAINING LBUFFR
C            CHARACTERS. THE CHARACTERS REPRESENT A SINGLE LINE.
C            THE ROUTINE MAINTAINS A ONE LINE LOOK AHEAD BUFFER IN
C            'COPY'.
C
      SUBROUTINE GETBUF(MBUFFR,BUFFER,LBUFFR,EOLFLG,EOFFLG)
 
      INTEGER MBUFFR, BUFFER(*), LBUFFR
      LOGICAL EOLFLG, EOFFLG
C
      INTEGER MAXCMT
      PARAMETER (MAXCMT = 1000)
 
      COMMON /INSTCM/ INSTAT
      INTEGER         INSTAT
      COMMON /CNTCRD/ NCONTC, MCONTC
      INTEGER         NCONTC, MCONTC
      COMMON /IOCNLS/ SOURCE,LISTNG
      INTEGER         SOURCE,LISTNG
      COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
      INTEGER         TOKNUM, STMNUM, PUNUM, PUNAME(134)
      COMMON /CMTSAV/ CMTSTR, LSTCMT, NXTCMT, LSTTKN
      INTEGER         LSTCMT, NXTCMT, CMTSTR(81, MAXCMT), LSTTKN
C
      LOGICAL FLAG, LACMNT, CMTFLG
      INTEGER LENGTH
C
      INTEGER I, IBEG, LISTOK, COPY(134)
      INTEGER CONTCR
C
      SAVE
C
C  NOTE: INSTAT IS SET TO -1 BY BLOCK DATA AND IS THEN AT 0 UNTIL AN
C        END-OF-FILE IS DETECTED.
C
      IF(INSTAT) 10, 70, 210
C
C FIRST CALL TO GETBUF, GET LOOKAHEAD CARD IMAGE
C
   10 INSTAT = 0
      NCONTC = 0
      LACMNT = .FALSE.
C
C  READ IN ANY COMMENT LINES THAT PRECEDE THE FIRST STATEMENT IN THE
C  FILE.
C
   20 CONTINUE
      CALL RDBUFF(COPY, FLAG, CMTFLG, SOURCE)
      IF(FLAG) GO TO 210
      IF(CMTFLG) THEN
        IF(.NOT. LACMNT) LACMNT = .TRUE.
        LSTCMT = LSTCMT + 1
        IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
        IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
        CALL SCOPY(COPY, 1, CMTSTR(1, LSTCMT), 1)
        IF(LISTNG .NE. -1) THEN
          CALL ZCHOUT('               .', LISTNG)
          CALL ZPTMES(COPY, LISTNG)
        ENDIF
        GO TO 20
      ENDIF
C
C FIRST STATEMENT FOUND
C
      IF(LACMNT) THEN
        LSTCMT = LSTCMT + 1
        IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
        IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
        CMTSTR(1, LSTCMT) = 36
      ENDIF
C
C PLACE LOOKAHEAD IMAGE INTO BUFFER
C
   70 CONTINUE
      IF(LACMNT) THEN
        BUFFER(1) = 35
        LBUFFR = 1
      ELSE
        LBUFFR = 0
      ENDIF
      IF(NCONTC .GT. 0) THEN
        IBEG = 7
      ELSE
        IBEG = 1
      ENDIF
      DO 90 I = IBEG, 73
        LBUFFR = LBUFFR + 1
        IF(COPY(I).LT.32) CALL SCNERR(11)
        BUFFER(LBUFFR) = COPY(I)
   90 CONTINUE
 
      LBUFFR = LBUFFR - 1
      IF(LISTNG .NE. -1) THEN
        IF(NCONTC .EQ. 0)  THEN
          CALL ZPTINT(STMNUM, 5, LISTNG)
          CALL ZCHOUT(' - ', LISTNG)
          IF(LACMNT) THEN
            CALL ZPTINT(TOKNUM+1, 6, LISTNG)
          ELSE
            CALL ZPTINT(TOKNUM, 6, LISTNG)
          ENDIF
        ELSE
          CALL ZCHOUT('              .', LISTNG)
        ENDIF
        CALL PUTCH(32, LISTNG)
        CALL ZPTMES(COPY, LISTNG)
      ENDIF
C
C GET NEW LOOKAHEAD IMAGE
C
      LACMNT = .FALSE.
C
C  GET THE NEXT LOOK AHEAD LINE. COMMENTS ARE HANDLED IMMEDIATLY
C  WHILE SEARCHING FOR THE NEXT LINE.
C
  120 CONTINUE
      CALL RDBUFF(COPY, FLAG, CMTFLG, SOURCE)
      IF(FLAG) GO TO 200
      IF(CMTFLG) THEN
        IF(.NOT. LACMNT) THEN
          LACMNT = .TRUE.
        ENDIF
        LSTCMT = LSTCMT + 1
        IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
        IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
        CALL SCOPY(COPY, 1, CMTSTR(1, LSTCMT), 1)
        IF(LISTNG .NE. -1) THEN
          CALL ZCHOUT('               .', LISTNG)
          CALL ZPTMES(COPY, LISTNG)
        ENDIF
        GO TO 120
      ENDIF
C
C NON-COMMENT CARD IMAGE FOUND
C
      IF(LACMNT) THEN
        LSTCMT = LSTCMT + 1
        IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
        IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
        CMTSTR(1, LSTCMT) = 36
      ENDIF
      CONTCR = COPY(6)
      IF(CONTCR .EQ. 32 .OR. CONTCR .EQ. 48) THEN
        NCONTC = 0
        EOLFLG = .TRUE.
        EOFFLG = .FALSE.
        DO 165 I = LBUFFR, 7, -1
          IF(BUFFER(I) .NE. 32) THEN
            BUFFER(I + 1) = 129
            LBUFFR = I
            RETURN
          ENDIF
  165   CONTINUE
        BUFFER(8) = 129
        LBUFFR    = 7
        RETURN
      ENDIF
C
C CONTINUATION LINE HANDLING
C
C SCNERR 20 : NUMBER OF CONTINUATION LINES MUST BE LESS THAN 19
C SCNERR 21 : LABEL FIELD OF CONTINUATION LINE IS NON-BLANK
C
      IF(NCONTC .GE. MCONTC) CALL SCNERR(20)
      NCONTC = NCONTC + 1
      DO 180 I = 1, 5
        IF(COPY(I) .NE. 32) CALL SCNERR(21)
  180 CONTINUE
      EOLFLG = .FALSE.
      EOFFLG = .FALSE.
      RETURN
C
C LOOKAHEAD IS END OF FILE
C
  200 EOLFLG = .TRUE.
      EOFFLG = .FALSE.
      INSTAT = 1
      RETURN
C
C CURRENT IMAGE IS END OF FILE
C
  210 CONTINUE
      EOFFLG = .TRUE.
      IF(LACMNT) CALL SCNERR(-1)
 
      END
C----------------------------------------------------------------------
C
C  ACTUAL INPUT ROUTINE, NOTE THAT THIS IS REPLACABLE, WHEREAS THE
C                        ROUTINE RDBUFF IS REUSABLE BY OTHER TOOLS
C
      INTEGER FUNCTION LXREAD(BUFFER, FD)
 
      INTEGER FD
      INTEGER BUFFER(*)
      INTEGER ZGTCMD
 
      LXREAD = ZGTCMD(BUFFER, FD)
 
      END
C----------------------------------------------------------------------
C
C  READ ROUTINE - READ IN A LINE FROM THE SOURCE FILE, DECIDE
C                 IF THE END OF FILE HAS BEEN REACHED, OR IF THE
C                 LINE IS A COMMENT. PAD NON-COMMENT LINES TO 72
C                 CHARACTERS (COMMENTS ARE TRUNCATED TO 80 CHARACTERS).
C                 A READ ERROR IS RETURNED AS E-O-F.
C
      SUBROUTINE RDBUFF(BUFFER, EOFFLG, CMTFLG, FD)
 
      INTEGER BUFFER(*), FD
      LOGICAL EOFFLG, CMTFLG
C
      INTEGER  LXREAD, ZLOWER, INDEXX, LENGTH
      INTEGER  LENT, I, J, LEGAL(12), TEMP(134)
      COMMON /CNTROL/ CMTLEN
      INTEGER CMTLEN
 
      SAVE /CNTROL/, LEGAL
 
      DATA LEGAL/32,48,49,50,51,52,53,54,55,56,57,129/
C
C  GET THE NEXT LINE - CHECK FOR ERRORS AND END-OF-FILE
C
      LENT = LXREAD(BUFFER, FD)
      IF(LENT .EQ. -100) THEN
        EOFFLG   = .TRUE.
        RETURN
      ELSE IF(LENT.EQ.-1) THEN
        CALL FTLERR(8)
      ENDIF
 
      EOFFLG   = .FALSE.
 
      I = 1
      CALL SKIPBL(BUFFER, I)
C
C  FIRST LOOK FOR LEGAL COMMENTS
C
      IF(BUFFER(1) .EQ. 67 .OR. BUFFER(1) .EQ. 42 .OR.
     +   BUFFER(1) .EQ. 99 .OR. BUFFER(I) .EQ. 129  .OR.
     +   I .GT. 72) THEN
        CMTFLG = .TRUE.
        BUFFER(CMTLEN+1) = 129
C
C  NOW ASSUMED COMMENTS
C
      ELSE IF(BUFFER(1).NE.9 .AND. INDEXX(LEGAL,BUFFER(1)).EQ.0) THEN
        CMTFLG = .TRUE.
        CALL SCNERR(-2)
        BUFFER(CMTLEN+1) = 129
C
C  OK, LINE IS BELIEVED TO BE PART OF A STATEMENT
C
C  CHECK FOR AND REMOVE TABS THEN ENSURE THAT
C
      ELSE
        CMTFLG = .FALSE.
 
        DO 100 I = 1, 6
          IF(BUFFER(I) .EQ. 9) THEN
            CALL SCNERR(-3)
            BUFFER(I) = 129
            CALL SCOPY(BUFFER, 1, TEMP, 1)
            DO 200 J = I, 6
              TEMP(J) = 32
  200       CONTINUE
            CALL SCOPY(BUFFER, I+1, TEMP, 7)
            CALL SCOPY(TEMP, 1, BUFFER, 1)
            LENT = LENGTH(BUFFER)
            GO TO 110
          ELSE IF(BUFFER(I) .EQ. 129) THEN
            GO TO 110
          ENDIF
  100   CONTINUE
 
  110   CONTINUE
        IF(LENT .LT. 72) THEN
          DO 10 I = LENT + 1, 72
            BUFFER(I) = 32
   10     CONTINUE
          BUFFER(73) = 129
        ENDIF
 
      ENDIF
 
      END
C-----------------------------------------------------------------
C
C  THE SCANNER ROUTINE. RETURNS ONE TOKEN PER CALL
C
      SUBROUTINE SCANNR
C
      INTEGER         SDNCPW, SDNCPS
      PARAMETER (SDNCPW=31, SDNCPS=128)
      COMMON /CHRBFC/ ICHAR, CBFSIZ, CBFEND, MCHAR, CHRBUF(1603)
      INTEGER         ICHAR, CBFSIZ, CBFEND, MCHAR, CHRBUF
      COMMON /CHICOM/ ERRCHI, EOLCHI, EOICHI, EOFCHI
      INTEGER         ERRCHI, EOLCHI, EOICHI, EOFCHI
      COMMON /AKTYPS/ KSTEP,  DSTEP,  CALL,   FECALL, VECALL, ELSE,
     +                OUTKTK, OUTDTK, SCREEN, EVAL,   END,    ERR,
     +                KADV,   DADV,   FCKADV, FCDADV, VCKADV, VCDADV,
     +                ELKSTP, ELDSTP, KTSCRN, DTSCRN, KTEVAL, DTEVAL
      INTEGER         KSTEP,  DSTEP,  CALL,   FECALL, VECALL, ELSE,
     +                OUTKTK, OUTDTK, SCREEN, EVAL,   END,    ERR,
     +                KADV,   DADV,   FCKADV, FCDADV, VCKADV, VCDADV,
     +                ELKSTP, ELDSTP, KTSCRN, DTSCRN, KTEVAL, DTEVAL
      COMMON /CURSTC/ ACT, CHAR, ERRORF, FBKUPC, NEWACT, ENDSCR
      INTEGER         ACT, CHAR,         FBKUPC, NEWACT
      LOGICAL                    ERRORF,                 ENDSCR
C
C  KSTACK - KEEP STACK, CONTAINS PAIRS OF START/END POINTERS TO KEPT STRINGS
C  MKSTAC - THE SIZE OF KSTACK
C  IKSTAC - THE KEEP STACK STACK-POINTER
C  KEEPF  - KEEP FLAG, TRUE TO KEEP CHARACTERS
C
      COMMON /KSTAKC/ IKSTAC, MKSTAC, KSTACK(2500), FTOKEN, TOKEN, KEEPF
      INTEGER         IKSTAC, MKSTAC, KSTACK, FTOKEN, TOKEN
      LOGICAL         KEEPF
C
C  CSTACK - CALL STACK FOR ACTIONS
C  MCSTAC - THE SIZE OF CSTACK
C  ICSTAC - THE ACTION CALL STACK STACK-POINTER
C
      COMMON /CSTAKC/ ICSTAC, MCSTAC, CSTACK(100)
      INTEGER         ICSTAC, MCSTAC, CSTACK
      COMMON /TCMAXC/ MTKNCH
      INTEGER         MTKNCH
      COMMON /TOKENC/ TKNTYP, KTFLAG, ITKNCH, TKNCHR(1327)
      INTEGER         TKNTYP,         ITKNCH, TKNCHR
      LOGICAL                 KTFLAG
      COMMON /NESTCM/ NSTELS
      INTEGER         NSTELS
      COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
      INTEGER         TOKNUM, STMNUM, PUNUM, PUNAME(134)
      INTEGER ACTSIZ
      PARAMETER (ACTSIZ = 2050)
      COMMON /XCDONE/ AA1(ACTSIZ),AA2(ACTSIZ),AA3(ACTSIZ),
     +                AA4(ACTSIZ),AA5(ACTSIZ)
      INTEGER         AA1,AA2,AA3,AA4,AA5
      COMMON /EXPTCM/ EXPONT(3)
      INTEGER EXPONT
C
      LOGICAL FCADVF, TEMPF, IN
      INTEGER I, IBEG, IEND, ITMP, NUM, TEMP
      INTEGER EXPVAL
      INTEGER OLDACT, BEGTOK, VAL, DIG, ATYPE, VALLC, DS
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
      SAVE
C
C START. INCREMENT THE TOKEN NUMBER
C
      TOKNUM = TOKNUM + 1
   10 IF(FTOKEN .LT. IKSTAC) GO TO 20
      IF(ENDSCR) GO TO 670
      IF(ACT .NE. 0) GO TO 30
      TKNTYP = TZEOF
      ITKNCH = 0
      RETURN
C
   20 ACT = KSTACK(FTOKEN)
      ATYPE = AA1(ACT)
      GO TO 340
C
C ADISP
   30 TEMP = CHAR
      IF(CHAR .LE. SDNCPS) TEMP = TEMP + 1
 
   31 CONTINUE
        IF(IN(TEMP, AA2(ACT))) GO TO 50
        ACT = ACT + 1
      GO TO 31
C
C DISPATCH
   50 ATYPE = AA1(ACT)
      GO TO(210,230,250,260,280,310,320,320,320,450,
     $      510,690, 60, 80,100,130,110,140,210,230,
     $      320,320,450,450), ATYPE
C
C KADV - KEEP AND ADVANCE
C
   60 IF(.NOT. KEEPF) THEN
        KEEPF = .TRUE.
        IKSTAC = IKSTAC + 1
        KSTACK(IKSTAC) = ICHAR
      ENDIF
      ICHAR = ICHAR + 1
      CALL ADVANC(ICHAR,CHRBUF,AA2(ACT))
      CHAR = CHRBUF(ICHAR)
      ACT = AA5(ACT)
      GO TO 30
C
C DADV - DELETE AND ADVANCE
C
   80 IF(KEEPF) THEN
        KEEPF = .FALSE.
        IKSTAC = IKSTAC + 1
        IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
        KSTACK(IKSTAC) = ICHAR
      ENDIF
      ICHAR = ICHAR + 1
      CALL ADVANC(ICHAR,CHRBUF,AA2(ACT))
      CHAR = CHRBUF(ICHAR)
      ACT = AA5(ACT)
      GO TO 30
C
C FCKADV
C
  100 FCADVF = .TRUE.
      GO TO 120
C
C VCKADV
C
  110 FCADVF = .FALSE.
C FCKADV(2) , VCKADV(2)
  120 DS = AA2(ACT)
      VALLC = AA4(ACT)
      VAL = EXPONT(VALLC)
      IF(VAL .EQ. 0) GO TO 200
      IF(KEEPF) GO TO 160
      IKSTAC = IKSTAC + 1
      KSTACK(IKSTAC) = ICHAR
      KEEPF = .TRUE.
      GO TO 160
C
C FCDADV
  130 FCADVF = .TRUE.
      GO TO 150
C
C VCDADV
  140 FCADVF = .FALSE.
C FCDADV(2) , VCDADV(2)
  150 DS = AA2(ACT)
      VALLC = AA4(ACT)
      VAL = EXPONT(VALLC)
      IF(VAL .EQ. 0) GO TO 200
      IF(KEEPF) THEN
        IKSTAC = IKSTAC + 1
        IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
        KSTACK(IKSTAC) = ICHAR
        KEEPF = .FALSE.
      ENDIF
C FCKADV(3) , FCDADV(3) , VCKADV(3) , VCDADV(3)
  160 ICHAR = ICHAR + 1
      VAL = VAL - 1
      IF(VAL .EQ. 0) GO TO 190
  170 TEMP = CHRBUF(ICHAR)
      IF(TEMP .LT. SDNCPS) TEMP = TEMP + 1
      IF(IN(TEMP,DS)) GO TO 160
      IF(CHRBUF(ICHAR).NE. EOICHI) GO TO 180
      TEMPF = KEEPF
      OLDACT = ACT
      CALL EOIERR
      IF(ACT .NE. OLDACT) GO TO 30
      IF(.NOT.TEMPF .OR. KEEPF) GO TO 170
      IKSTAC = IKSTAC + 1
      KSTACK(IKSTAC) = ICHAR
      KEEPF = .TRUE.
      GO TO 170
C
C CHAR NOT IN CHARACTER SET
C
  180 IF(.NOT.FCADVF) GO TO 190
      ERRORF = .TRUE.
      IF(NSTELS .GT. 0) GO TO 730
      IF(CHRBUF(ICHAR).EQ. EOFCHI) GO TO 720
      CHRBUF(ICHAR) = ERRCHI
      GO TO 160
C
  190 CHAR = CHRBUF(ICHAR)
  200 ACT = AA5(ACT)
      GO TO 30
C
C KSTEP - KEEP AND STEP
C
  210 IF(.NOT. KEEPF) THEN
        IKSTAC = IKSTAC + 1
        KSTACK(IKSTAC) = ICHAR
        KEEPF = .TRUE.
      ENDIF
      ICHAR = ICHAR + 1
      CHAR = CHRBUF(ICHAR)
      ACT = AA5(ACT)
      GO TO 30
C
C DSTEP - DELETE AND STEP
C
  230 IF(KEEPF) THEN
        IKSTAC = IKSTAC + 1
        IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
        KSTACK(IKSTAC) = ICHAR
        KEEPF = .FALSE.
      ENDIF
      ICHAR = ICHAR + 1
      CHAR = CHRBUF(ICHAR)
      ACT = AA5(ACT)
      GO TO 30
C
C CALL
  250 ICSTAC = ICSTAC + 1
      IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
      CSTACK(ICSTAC) = ACT
      ACT = AA3(ACT)
      GO TO 30
C
C FECALL
  260 VALLC = AA4(ACT)
      VAL = EXPONT(VALLC)
      IF(VAL .GT. 0) GO TO 270
      ACT = AA5(ACT)
      GO TO 30
C
  270 ICSTAC = ICSTAC + 2
      IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
      CSTACK(ICSTAC-1) = VAL - 1
      CSTACK(ICSTAC) = ACT
      ACT = AA3(ACT)
      GO TO 30
C
C VECALL
  280 VALLC = AA4(ACT)
      VAL = EXPONT(VALLC)
      IF(VAL .NE. 0) GO TO 290
      ACT = AA5(ACT)
      GO TO 30
C
  290 ICSTAC = ICSTAC + 5
      IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
      CSTACK(ICSTAC) = ACT
C VECALL(2) , END VECALL(2)
  300 NSTELS = NSTELS + 1
      IF(NSTELS .EQ. 1) FBKUPC = ICHAR
      CSTACK(ICSTAC-4) = IKSTAC
      IF(KEEPF) CSTACK(ICSTAC-4) = -IKSTAC
      CSTACK(ICSTAC-3) = TOKEN
      IF(ERRORF) CSTACK(ICSTAC-3) = -TOKEN
      CSTACK(ICSTAC-2) = ICHAR
      CSTACK(ICSTAC-1) = VAL - 1
      ACT = AA3(ACT)
      GO TO 30
C
C ELSE
  310 ICSTAC = ICSTAC + 4
      IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
      CSTACK(ICSTAC-3) = IKSTAC
      IF(KEEPF) CSTACK(ICSTAC-3) = -IKSTAC
      CSTACK(ICSTAC-2) = TOKEN
      IF(ERRORF) CSTACK(ICSTAC-2) = -TOKEN
      CSTACK(ICSTAC-1) = ICHAR
      CSTACK(ICSTAC) = ACT
      IF(NSTELS .EQ. 0) FBKUPC = ICHAR
      NSTELS = NSTELS + 1
      ACT = AA3(ACT)
      GO TO 30
C
C OUTKTK , OUTDTK , SCREEN , KTSCRN , DTSCRN
  320 IF(KEEPF) THEN
        IKSTAC = IKSTAC + 1
        IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
        KSTACK(IKSTAC) = ICHAR
        KEEPF = .FALSE.
      END IF
C OUTKTK(2), OUTDTK(2), SCREEN(2), KTSCRN(2), DTSCRN(2), KTEVAL(2), DTEV
  330 NEWACT = AA5(ACT)
      IKSTAC = IKSTAC + 2
      KSTACK(IKSTAC-1) = 0
      IF(ERRORF) KSTACK(IKSTAC-1) = -1
      ERRORF = .FALSE.
      IF(NSTELS .NE. 0) THEN
        KSTACK(TOKEN) = ACT
        TOKEN = IKSTAC
        ACT = NEWACT
        GO TO 30
      END IF
C
  340 FTOKEN = FTOKEN + 1
      IF(ATYPE .EQ. SCREEN .OR. ATYPE .EQ. KTSCRN .OR.
     $  ATYPE .EQ. DTSCRN) GO TO 400
C OUTKTK(3) , OUTDTK(3) , KTEVAL(3) , DTEVAL(3)
      ITKNCH = 0
      KTFLAG = .FALSE.
      IF(ATYPE .EQ. OUTKTK .OR. ATYPE .EQ. KTEVAL) KTFLAG = .TRUE.
  350 CONTINUE
      IBEG = KSTACK(FTOKEN)
      IF(IBEG .GT. 0) THEN
        IF(KTFLAG) THEN
          IEND = KSTACK(FTOKEN+1) - 1
          DO 360 I = IBEG, IEND
            ITKNCH = ITKNCH + 1
            IF(ITKNCH .LE. MTKNCH) TKNCHR(ITKNCH) = CHRBUF(I)
  360     CONTINUE
        END IF
        FTOKEN = FTOKEN + 2
        GO TO 350
      END IF
C
      IF(ITKNCH .GT. MTKNCH) THEN
        CALL SCNERR(1)
        ITKNCH = MTKNCH
      ENDIF
      FTOKEN = FTOKEN + 1
      IF(IBEG .LT. 0) CALL SCNERR(2)
      TKNTYP = AA4(ACT)
      IF(FTOKEN .LT. IKSTAC) RETURN
C
      IKSTAC = 1
      FTOKEN = 1
      TOKEN = 1
      ACT = NEWACT
      RETURN
C
C SCREEN(3) , KTSCRN(3) , DTSCRN(3)
  400 BEGTOK = KSTACK(FTOKEN)
      IF(BEGTOK .LE. 0) THEN
        BEGTOK = ICHAR
        ITMP = ICHAR
      ELSE
C
        ITMP = KSTACK(FTOKEN+1)
  420   FTOKEN = FTOKEN + 2
        IBEG = KSTACK(FTOKEN)
        IF(IBEG .GT. 0) THEN
          IEND = KSTACK(FTOKEN+1) - 1
          DO 430 I = IBEG, IEND
            IF(ITMP .EQ. MCHAR) ITMP = 1
            CHRBUF(ITMP) = CHRBUF(I)
            ITMP = ITMP + 1
  430     CONTINUE
          GO TO 420
        END IF
      END IF
C
      IF(IBEG .LT. 0) CALL SCNERR(3)
      ICSTAC = ICSTAC + 7
C FTLERR 2 : CALL STACK OVERFLOW
      IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
      CSTACK(ICSTAC-6) = NEWACT
      CSTACK(ICSTAC-5) = ICHAR
      CSTACK(ICSTAC-4) = BEGTOK
      ICHAR = BEGTOK
      CHAR = CHRBUF(BEGTOK)
      CSTACK(ICSTAC-3) = IKSTAC
      CSTACK(ICSTAC-2) = CHRBUF(ITMP)
      CHRBUF(ITMP) = EOFCHI
      CSTACK(ICSTAC-1) = FTOKEN + 1
      FTOKEN = IKSTAC
      TOKEN = IKSTAC
      KEEPF = .FALSE.
      CSTACK(ICSTAC) = ACT
      IF(AA4(ACT).GT. 0) NSTELS = NSTELS + 1
      ACT = AA3(ACT)
      GO TO 30
C
C EVAL , KTEVAL , DTEVAL
  450 IF(KEEPF) THEN
        IKSTAC = IKSTAC + 1
        IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
        KSTACK(IKSTAC) = ICHAR
        KEEPF = .FALSE.
      ENDIF
      NUM = 0
      ITMP = TOKEN
  470 IF(ITMP .NE. IKSTAC) THEN
        IBEG = KSTACK(ITMP+1)
        ITMP = ITMP + 2
        IEND = KSTACK(ITMP) - 1
        DO 480 I = IBEG, IEND
          NUM =(NUM*10) + CHRBUF(I) - 48
  480   CONTINUE
        GO TO 470
      END IF
C
      VALLC = AA3(ACT)
      EXPONT(VALLC) = NUM
      IF(ATYPE .NE. EVAL) GO TO 330
C EVAL(2)
      IF(ERRORF) THEN
C ERROR 2 : ERROR IN TOKEN
        CALL SCNERR(2)
        ERRORF = .FALSE.
      ENDIF
      IKSTAC = TOKEN
      ACT = AA5(ACT)
      GO TO 30
C
C END
  510 IF(CHAR .EQ. EOICHI) THEN
C IF END IS ONLY ALTERNATIVE IN THIS STATE, DELAY CALL TO EOIERR UNTIL P
C DECREMENTATION OF NSTELS (BY END VECALL) TO MAXIMIZE CHRBUF OVERLAP
        IF(AA5(ACT) .NE. ACT) THEN
          ACT = AA5(ACT)
          CALL EOIERR
          GO TO 30
        ENDIF
      END IF
C
      ACT = CSTACK(ICSTAC)
      IF(ACT .EQ. 0) GO TO 10
C
      ATYPE = AA1(ACT)
      GO TO(680,680,540,550,570,590,680,680,640,680,
     $  680,680,680,680,680,680,680,680,680,680,
     $  600,600,680,680), ATYPE
C
C END CALL
  540 ICSTAC = ICSTAC - 1
      ACT = AA5(ACT)
      GO TO 30
C
C END FECALL
  550 VAL = CSTACK(ICSTAC-1)
      IF(VAL .GT. 0) GO TO 560
      ICSTAC = ICSTAC - 2
      ACT = AA5(ACT)
      GO TO 30
C
  560 CSTACK(ICSTAC-1) = VAL - 1
      ACT = AA3(ACT)
      GO TO 30
C
C END VECALL
  570 VAL = CSTACK(ICSTAC-1)
      NSTELS = NSTELS - 1
C CHECK IF EOIERR SHOULD BE CALLED, DELAYED TILL HERE SO THAT DECREMENTA
C OF NSTELS WILL ALLOW MAXIMUM OVERLAP OF CHRBUF
      IF(CHAR .EQ. EOICHI) THEN
        OLDACT = ACT
        CALL EOIERR
        IF(ACT .NE. OLDACT) GO TO 30
      ENDIF
      IF(VAL .NE. 0) GO TO 300
      ICSTAC = ICSTAC - 5
      ACT = AA5(ACT)
      IF(NSTELS .GT. 0 .OR. TOKEN .EQ. FTOKEN) GO TO 30
      NEWACT = ACT
      GO TO 20
C
C END ELSE
  590 ICSTAC = ICSTAC - 4
      NSTELS = NSTELS - 1
      ACT = AA5(ACT)
      IF(NSTELS .GT. 0 .OR. TOKEN .EQ. FTOKEN) GO TO 30
      NEWACT = ACT
      GO TO 20
C
C END KTSCRN , END DTSCRN
  600 ENDSCR = .TRUE.
      NSTELS = NSTELS - 1
      IF(CHAR .NE. EOFCHI) GO TO 610
      IF(TOKEN .EQ. FTOKEN) GO TO 670
      NEWACT = ACT
      GO TO 20
C
C END KTSCRN(2) , END DTSCRN(2) , ERR KTSCRN(2) , ERR DTSCRN(2)
  610 FTOKEN = IKSTAC
      TKNTYP = AA4(ACT)
      ITKNCH = 0
      IF(ATYPE .EQ. DTSCRN) THEN
        KTFLAG = .FALSE.
        RETURN
      ENDIF
C
      KTFLAG = .TRUE.
      ICHAR = CSTACK(ICSTAC-4)
  620 IF(CHRBUF(ICHAR).EQ. EOFCHI) GO TO 630
      ITKNCH = ITKNCH + 1
      IF(ITKNCH .LE. MTKNCH) TKNCHR(ITKNCH) = CHRBUF(ICHAR)
      ICHAR = ICHAR + 1
      IF(ICHAR .EQ. MCHAR) I = 1
      GO TO 620
C
  630 IF(ITKNCH .LE. MTKNCH) RETURN
      CALL SCNERR(1)
      ITKNCH = MTKNCH
      RETURN
C
C END SCREEN
  640 IF(CHAR .EQ. EOFCHI) GO TO 660
      CALL SCNERR(4)
  650 ICHAR = ICHAR + 1
      IF(ICHAR .EQ. MCHAR) ICHAR = 1
      IF(CHRBUF(ICHAR).NE. EOFCHI) GO TO 650
C END SCREEN(2) , ERR SCREEN(2)
  660 IF(.NOT.ERRORF) GO TO 670
      CALL SCNERR(5)
      ERRORF = .FALSE.
C
C END SCREEN(2) , END KTSCRN(3) , END DTSCRN(3) , ERR KTSCRN(3) , ERR KT
C
  670 ENDSCR = .FALSE.
      FTOKEN = CSTACK(ICSTAC-1)
      CHAR   = CSTACK(ICSTAC-2)
      CHRBUF(ICHAR) = CHAR
      IKSTAC = CSTACK(ICSTAC-3)
      KEEPF = .FALSE.
      ICHAR = CSTACK(ICSTAC-5)
      CHAR = CHRBUF(ICHAR)
      NEWACT = CSTACK(ICSTAC-6)
      ICSTAC = ICSTAC - 7
      IF(FTOKEN .LT. IKSTAC) GO TO 20
      IKSTAC = 1
      FTOKEN = 1
      TOKEN = 1
      ACT = NEWACT
      GO TO 30
C
C END-ERROR
C
  680 CALL FTLERR(3)
C ERR
  690 ACT = AA5(ACT)
      IF(CHAR .EQ. EOICHI) THEN
        CALL EOIERR
        GO TO 30
      END IF
C
  700 IF(NSTELS .GT. 0) GO TO 730
      IF(CHAR .NE. EOFCHI) THEN
        CHRBUF(ICHAR) = ERRCHI
        ERRORF = .TRUE.
        ICHAR  = ICHAR + 1
        CHAR   = CHRBUF(ICHAR)
        GO TO 30
      END IF
C
  720 IF(ICSTAC .LE. 0) THEN
        CALL SCNERR(6)
        ITKNCH = 0
        TKNTYP = TZEOF
        ACT = 0
        RETURN
      END IF
C
  730 ACT = CSTACK(ICSTAC)
      IF(ACT .EQ. 0) THEN
        CALL SCNERR(7)
        GO TO 10
      END IF
C
      ATYPE = AA1(ACT)
      GO TO(850,850,750,760,770,780,850,850,840,850,
     $  850,850,850,850,850,850,850,850,850,850,
     $  830,830,850,850), ATYPE
C
C ERR CALL
  750 ICSTAC = ICSTAC - 1
      GO TO 700
C
C ERR FCALL
  760 ICSTAC = ICSTAC - 2
      GO TO 700
C
C ERR VECALL
  770 ICSTAC = ICSTAC - 1
C ERR ELSE , ERR VECALL(2)
  780 ICHAR = CSTACK(ICSTAC-1)
      CHAR = CHRBUF(ICHAR)
      TOKEN = CSTACK(ICSTAC-2)
      ERRORF = .FALSE.
      IF(TOKEN .LE. 0) THEN
        TOKEN = -TOKEN
        ERRORF = .TRUE.
      END IF
      IKSTAC = CSTACK(ICSTAC-3)
      KEEPF = .FALSE.
      IF(IKSTAC .LE. 0) THEN
        IKSTAC = -IKSTAC
        KEEPF = .TRUE.
      END IF
      IF(ATYPE .EQ. VECALL) THEN
        ACT = AA5(ACT)
      ELSE
  810   ACT = AA4(ACT)
        ATYPE = AA1(ACT)
        IF (ATYPE.EQ.ELSE .OR. ATYPE.EQ.ELKSTP .OR.
     +      ATYPE.EQ.ELDSTP) THEN
          TEMP = CHAR
          IF(CHAR .LE. SDNCPS) TEMP = TEMP + 1
          IF(IN(TEMP,AA2(ACT))) THEN
            CSTACK(ICSTAC) = ACT
            ACT = AA3(ACT)
            GO TO 30
          ELSE
            GOTO 810
          END IF
        END IF
      END IF
C
      ICSTAC = ICSTAC - 4
      NSTELS = NSTELS - 1
      IF(NSTELS .GT. 0 .OR. TOKEN .EQ. FTOKEN) GO TO 30
      NEWACT = ACT
      GO TO 20
C
C ERR KTSCRN , ERR DTSCRN
  830 ERRORF = .FALSE.
      ENDSCR = .TRUE.
      NSTELS = NSTELS - 1
      FTOKEN = IKSTAC
      GO TO 610
C
C ERR SCREEN
  840 CALL SCNERR(8)
      GO TO 660
C
C ERR-ERR
  850 CALL FTLERR(4)
C
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE EOIERR
C
      COMMON /BFFRCM/MBUFFR,BUFFER(82)
      INTEGER        MBUFFR,BUFFER
      COMMON /CSTAKC/ICSTAC,MCSTAC,CSTACK(100)
      INTEGER        ICSTAC,MCSTAC,CSTACK
      COMMON /CHRBFC/ICHAR,CBFSIZ,CBFEND,MCHAR,CHRBUF(1603)
      INTEGER        ICHAR,CBFSIZ,CBFEND,MCHAR,CHRBUF
      COMMON /KSTAKC/IKSTAC,MKSTAC,KSTACK(2500),FTOKEN,TOKEN,KEEPF
      INTEGER        IKSTAC,MKSTAC,KSTACK,FTOKEN,TOKEN
      LOGICAL        KEEPF
      COMMON /CHICOM/ERRCHI,EOLCHI,EOICHI,EOFCHI
      INTEGER        ERRCHI,EOLCHI,EOICHI,EOFCHI
      COMMON /CURSTC/ACT,CHAR,ERRORF,FBKUPC,NEWACT,ENDSCR
      INTEGER        ACT,CHAR,FBKUPC,NEWACT
      LOGICAL        ERRORF,ENDSCR
      COMMON /NESTCM/NSTELS
      INTEGER        NSTELS
C
      LOGICAL EOLFLG,EOFFLG
      INTEGER FCIBUF,FBCTMP,LBUFFR,ITOK,IBUF,I
      SAVE
C
      IF (ICHAR.GE.MCHAR) THEN
          IF (KEEPF) THEN
              IKSTAC = IKSTAC + 1
              IF (IKSTAC.GT.MKSTAC) CALL FTLERR(1)
              KSTACK(IKSTAC) = ICHAR
              KEEPF = .FALSE.
          END IF
          ICHAR = 1
          CHAR = CHRBUF(1)
          IF (CHAR.NE.EOICHI) RETURN
      END IF
C
C GETBUF STORES MBUFFR CHARACTERS INTO BUFFER
C
      CALL GETBUF(MBUFFR,BUFFER,LBUFFR,EOLFLG,EOFFLG)
      IF (EOFFLG) THEN
          CHRBUF(ICHAR) = EOFCHI
          CHAR = EOFCHI
          RETURN
      ELSE IF (ERRORF) THEN
          CALL SCNERR(9)
          ERRORF = .FALSE.
          ICHAR = 1
          ACT = 1
          IKSTAC = 1
          FTOKEN = 1
          TOKEN = 1
          KEEPF = .FALSE.
          ICSTAC = 1
          NSTELS = 0
          GO TO 300
      END IF
C
      IF (NSTELS.LE.0 .AND. .NOT. KEEPF) THEN
          IF (TOKEN.LT.IKSTAC) THEN
C
C  INPUT APPEARS TO BE COMING FROM SAVED STRINGS
C
              ICHAR = KSTACK(IKSTAC)
          ELSE
              ICHAR = 1
              GO TO 300
          END IF
      END IF
      ITOK = FTOKEN + 1
  100 CONTINUE
      IF (ITOK.LE.IKSTAC) THEN
          FCIBUF = KSTACK(ITOK)
          IF (FCIBUF.GT.0) THEN
              GO TO 200
          ELSE
              ITOK = ITOK + 2
              GO TO 100
          END IF
      END IF
C
      FCIBUF = ICHAR
  200 IF (FCIBUF.LE.ICHAR) FCIBUF = CBFEND + FCIBUF
      IF (NSTELS.NE.0) THEN
          FBCTMP = FBKUPC
          IF (FBKUPC.LE.ICHAR) FBCTMP = CBFEND + FBKUPC
          IF (FCIBUF.GT.FBCTMP) FCIBUF = FBCTMP
      END IF
C
C  CHECK FOR OVERFLOW, RESET IF FOUND
C
      IF (ICHAR+LBUFFR.GE.FCIBUF-1) THEN
          CALL SCNERR(10)
          ICHAR = 1
          ACT = 1
          IKSTAC = 1
          FTOKEN = 1
          TOKEN = 1
          KEEPF = .FALSE.
          ICSTAC = 1
          NSTELS = 0
      END IF
C
C COPY THE LATEST LINE INTO THE RING BUFFER
C
  300 IBUF = ICHAR
      DO 400 I = 1,LBUFFR
          CHRBUF(IBUF) = BUFFER(I)
          IBUF = IBUF + 1
          IF (IBUF.EQ.MCHAR) IBUF = 1
  400 CONTINUE
 
      IF (EOLFLG) THEN
          CHRBUF(IBUF) = EOLCHI
          IBUF = IBUF + 1
          IF (IBUF.EQ.MCHAR) IBUF = 1
      END IF
      CHRBUF(IBUF) = EOICHI
      CHAR = CHRBUF(ICHAR)
 
      END
C----------------------------------------------------------------------
C
      SUBROUTINE SCNERR(ERRNUM)
 
      INTEGER ERRNUM
      COMMON /ERRORC/ NRCVER
      INTEGER NRCVER
      COMMON /IOCNLS/ SOURCE,LISTNG
      INTEGER SOURCE,LISTNG
      COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
      INTEGER TOKNUM, STMNUM, PUNUM, PUNAME(134), FD
      SAVE
 
      IF(LISTNG .EQ. -1) THEN
        FD = 2
      ELSE
        FD = LISTNG
      ENDIF
C
C  ERRORS
C
      IF(ERRNUM .EQ. 1) THEN
        CALL ZMESS
     + ('SCAN ERROR 1 : TOKEN TOO LONG.', FD)
      ELSE IF(ERRNUM .EQ. 2) THEN
        CALL ZMESS
     + ('SCAN ERROR 2 : ERROR IN TOKEN.', FD)
      ELSE IF(ERRNUM .EQ. 3) THEN
        CALL ZMESS
     + ('SCAN ERROR 3 : ERROR IN TOKEN TO BE SCREENED.', FD)
      ELSE IF(ERRNUM .EQ. 4) THEN
        CALL ZMESS
     + ('SCAN ERROR 4 : UNPROCESSED TEXT REMAINING TO BE SCREENED.',FD)
      ELSE IF(ERRNUM .EQ. 5) THEN
        CALL ZMESS
     + ('SCAN ERROR 5 : SCREEN ENDED IN ERROR ACTION.', FD)
      ELSE IF(ERRNUM .EQ. 6) THEN
        CALL ZMESS
     + ('SCAN ERROR 6 : EOF READ UNEXPECTEDLY.', FD)
      ELSE IF(ERRNUM .EQ. 7) THEN
        CALL ZMESS
     + ('SCAN ERROR 7 : SCAN ENDED IN ERROR ACTION.', FD)
      ELSE IF(ERRNUM .EQ. 8) THEN
        CALL ZMESS
     + ('SCAN ERROR 8 : SCREENED TOKEN ENDS UNEXPECTEDLY.', FD)
      ELSE IF(ERRNUM .EQ. 9) THEN
        CALL ZMESS
     + ('SCAN ERROR 9 : END OF BUFFER REACHED IN ERROR, RESET.',FD)
      ELSE IF(ERRNUM .EQ. 10) THEN
        CALL ZMESS
     + ('SCAN ERROR 10: BUFFER OVERFLOW , RESET.', FD)
      ELSE IF(ERRNUM .EQ. 20) THEN
        CALL ZMESS
     + ('SCAN ERROR 20: TOO MANY CONTINUATION LINES.', FD)
      ELSE IF(ERRNUM .EQ. 21) THEN
        CALL ZMESS
     + ('SCAN ERROR 21: NON-BLANK LABEL ON CONTINUATION LINE.', FD)
      ELSE IF(ERRNUM .EQ. 23) THEN
        CALL ZMESS
     + ('SCAN ERROR 23: INITIAL LINE LOOKED LIKE END STATEMENT.', FD)
      ELSE IF(ERRNUM .EQ. 24) THEN
        CALL ZMESS
     + ('SCAN ERROR 24: UNNAMED FUNCTION OR SUBROUTINE.', FD)
C
C  WARNINGS
C
      ELSE IF(ERRNUM .EQ. -1) THEN
        CALL ZMESS
     + ('SCAN WARNING : COMMENTS DELETED AFTER LAST PROGRAM UNIT.', FD)
      ELSE IF(ERRNUM .EQ. -2) THEN
        CALL ZMESS
     + ('SCAN WARNING : UNRECOGNIZED LINE, ASSUMED COMMENT.', FD)
      ELSE IF(ERRNUM .EQ. -3) THEN
        CALL ZMESS
     + ('SCAN WARNING : TAB IN LABEL FIELD.', FD)
C
C  WHO KNOWS?
C
      ELSE
        CALL ZMESS
     + ('UNKNOWN SCAN ERROR: .', FD)
      ENDIF
C
      IF(ERRNUM .GT. 0) THEN
        NRCVER = MAX(1, NRCVER + 1)
      ELSE IF(ERRNUM .LT. 0) THEN
        IF(NRCVER .LE. 0) NRCVER = NRCVER - 1
        IF(ERRNUM .EQ. -1) RETURN
      ENDIF
 
      CALL ZCHOUT('               .', FD)
      CALL PUTLIN(PUNAME, FD)
      CALL ZCHOUT(' STATEMENT: .', FD)
      CALL ZPTINT(STMNUM, 1, FD)
      CALL ZCHOUT(' (NEAR TOKEN: .', FD)
      CALL ZPTINT(TOKNUM, 1, FD)
      CALL PUTCH(41, FD)
      CALL PUTCH(10, FD)
 
      END
C--------------------------------------------------------------------------
C
C  REPORT FATAL ERRORS ACCORDING TO ERROR NUMBER AND THEN QUIT
C
      SUBROUTINE FTLERR(FERNUM)
      INTEGER FERNUM
C
      COMMON /IOCNLS/ SOURCE,LISTNG
      INTEGER         SOURCE,LISTNG
      COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
      INTEGER TOKNUM, STMNUM, PUNUM, PUNAME(134), FD
      SAVE
C
      IF(LISTNG .EQ. -1) THEN
        FD = 2
      ELSE
        FD = LISTNG
      ENDIF
      IF(FERNUM .EQ. 1) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 1: KEEP STACK OVERFLOW.', FD)
      ELSE IF(FERNUM .EQ. 2) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 2: CALL STACK OVERFLOW.', FD)
      ELSE IF(FERNUM .EQ. 3) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 3: ILLEGAL ACTION ON CALL STACK.', FD)
      ELSE IF(FERNUM .EQ. 4) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 4: ERROR IN BACKUP.', FD)
      ELSE IF(FERNUM .EQ. 5) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 5: EMPTY INPUT BUFFER TO SCANNER.', FD)
      ELSE IF(FERNUM .EQ. 6) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 6: INPUT LARGER THAN SCANNER BUFFER.', FD)
      ELSE IF(FERNUM .EQ. 7) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 7: SYNTACTIC STACK OVERFLOW.', FD)
      ELSE IF(FERNUM .EQ. 8) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 8: READ BUFFER ERROR.', FD)
      ELSE IF(FERNUM .EQ. 9) THEN
        CALL ZMESS
     +  ('SCAN FATAL ERROR 9: COMMENT BLOCK TOO LONG.', FD)
      ELSE
        CALL ZMESS
     +  ('SCAN UNKNOWN FATAL ERROR: .', FD)
      ENDIF
C
      CALL ZCHOUT('                    .', FD)
      CALL PUTLIN(PUNAME, FD)
      CALL ZCHOUT(' STATEMENT: .', FD)
      CALL ZPTINT(STMNUM, 1, FD)
      CALL ZCHOUT(' (NEAR TOKEN: .', FD)
      CALL ZPTINT(TOKNUM, 1, FD)
      CALL PUTCH(41, FD)
      CALL PUTCH(10, FD)
C
      CALL ZQUIT(-1)
 
      END
